Let’s create a graphical table to summarize our studbook data.
studbook.tbl <- studbook %>% studbook_react(., studbook.cols(.), groupBy = "Status")
studbook.tbl
Let’s look at the basic population size over time to begin quantifying growth rate and assessing overall population viability.
raw.counts <- census(timeline, studbook, "years")
population.plot <- plot_census(raw.counts, colors, "Pygmy Loris Population Trends 1966-2025")
population.plot
Now we will use annual birth counts to follow the standard method for computing a normalized rate of growth over the past 5 years compared to all years.
lifeTab <- cohort_lifeTab(timeline, studbook, 1985, 2024, 5, 22)
And then we will plot trends in this growth rate based on birth year.
lambda.plot <- plot_lambda(lifeTab, colors, "Population Growth Rates by Cohort")
lambda.plot
Now we will use a package called pedtools to create our
pedigree objects based on the studbook data. We will use the pedigree
object to generate all genetic stats and projections.
pedig <- ped(
id = studbook$ID,
fid = studbook$Sire,
mid = studbook$Dam,
sex = studbook$sex_ped
) %>% discard(., \(x) pedtools::pedsize(x) <= 1)
The object pedig most likely contains a list of multiple
pedigree objects, as any founders or lineages not represented in the
current living population will form discrete, disconnected trees. There
also will probably be several “singletons” which are founders without
any connections to the living population. That is why the code above
also included a line to thin out your dataset by ignoring the founders
that never reproduced.
Now we will take a look at your data in the form of the traditional pedigree structures we covered in class. The code below will prepare some formatting variables to assign color-coding before plotting the pedigree(s) you already created.
ped_list_plots <- plot_ped_series(pedig, colors, studbook)
ped_list_plots
$`_comp5`
$`_comp11`
$`_comp13`
$`_comp23`
$`_comp26`
Most of you probably still have multiple plots, one of which looks
much more complicated than the others. We can thin our dataset out even
more by filtering for just those individuals still represented in the
living population. That means we want to set aside any of the lineages
where the descendants are no longer related to any living individuals
through surviving siblings, offspring, nieces, nephews, etc. In most
cases, that will leave us with one large and complicated pedigree
representing all the contemporary diversity in our population. You
should inspect the plots about and decide which one to carry forward for
your analysis, based on this concept. Once you have done so, update the
"_comp5" in the code chunk below with the title you see for
your chosen plot. You will need to click “run code” before proceeding.
Note: you can come back and run the code chunk again any time with a
different name inserted, and all future steps will update based on that
selection.
includes_living <- c("_comp5")
ped.living <- keep_at(pedig, includes_living)
ped.living <- ped.living[[1]]
famid(ped.living) <- "Current"
ped_living_plot <- plot_pedigree(ped.living,
"Pedigree of Living Population",
studbook,
set_ped_fills(ped.living, colors, studbook))
I don’t love the pedtools graphics system and lack of
customization/interactivity, so if we want to look more closely at the
details of relationships and clustering across a complex pedigree, we
can transfer the data produced by pedtools into some other visualization
packages. In this case, we will use visNetwork Run the
chunk below to render two different visualizations.
ped.net <- ped_network(ped.living, colors, studbook)
ped.vert <- ped.net %>% visHierarchicalLayout(direction = "UD", shakeTowards = "roots")
First, you will generate a hierarchical plot that resembles the traditional pedigree structure above. Note that the horizontal-bar icons represent each mother-father pair with one or more shared offspring. The dotted lines lead from each parent to the icon representing their parental unit, with color-coding and labels corresponding to the institution where the pair produced their shared offspring. The solid lines coming from each bar-icon connect the parental unit to the offspring that would be full-siblings.
Note: these plots depend on some more memory-intensive javascript code, so you will experience more of a delay than usual before the image loads. If you see a blank plotting area at first, just wait a few minutes for the image to appear.
Second, you will view the same plot as a network instead of a hierarchy. This gives a clearer representation of the clustering around particularly successful mated pairs and institutions.
Note: this one takes even longer to load than the previous plot.
Next, we will generate some of the descriptive statistics that we can use to assess the long-term viability of our populations and make some breeding recommendations.
We will need information about founders still represented in the living population, which we can summarize with the code below.
founder.summary <- founder_summary(pedig, ped.living, studbook)
founder.vis <- founder.summary %>% studbook_react(., cols = founder.cols(.))
Now we will generate some additional stats to give us a similar glimpse of the historical lineage, current representation, and breeding success of our living population.
We will use the pedigree object to calculate an inbreeding coefficient for each individual in the living population.
The autosomal inbreeding coefficient of a pedigree member is defined as the probability that, at a random autosomal locus, the two alleles carried by the member are identical by descent, relative to the pedigree.
It follows from the definition that the inbreeding coefficient of a non-founder equals the kinship coefficient of the parents.
<>
inbred.ped <- inbreeding(ped.living) %>% enframe(name = "ID", value = "inbred")
inbred.tbl <- datatable(inbred.ped)
This gives us some information about each individual’s genetic history, especially their potential to contribute more/less genetic diversity to the next generation, but what does that mean when they are matched to an individual with a higher/lower inbreeding coefficient? When we match individuals, two individuals with moderate inbreeding coefficients but little shared ancestory might still have a positive or neutral impact on the population’s long-term viability. That is why we will also calculate a pairwise metric to score each potential match - the kinship coefficient.
For two (possibly equal) members A, B of a pedigree, their autosomal (resp. X-chromosomal) kinship coefficient is defined as the probability that a random allele from A and a random allele from B, sampled at the same autosomal (resp. X-chromosomal) locus, are identical by descent, relative to the pedigree.
<>
kinship.ped <- ribd::kinship(ped.living)
living.ped <- intersect(living, rownames(kinship.ped))
living.kinship <- kinship.ped[living.ped, living.ped]
kinship.mat <- datatable(living.kinship)
The code above created a matrix that we will use in other code chunks below.
We can also extract some basic counts from our pedigree for each individual before we create some visual summaries below.
living.summary <- family_history(ped.living, studbook) %>%
studbook_react(.,
cols = living.cols(.),
columnGroups = list(kin.group())
)
Finally, we want to look closer at potential breeding pairs to do some match-making, so let’s generate some more pedigree statistics per individual and then visualize a plot of breeding pairs.
kinship_btp <- subset_matrix_living(living.kinship, studbook)
btp.plot <- matrix.heatmap(kinship_btp, "Kinship Values for Potential Mate Pairs", "Kinship Vals")
Once you choose some potential pairs, you should plug their ID’s into the code chunks below. You need to click “run code” to log your entry for selected pair ids before proceeding. This will give you a few more graphics to inspect their relationship. You can easily swap out different IDs and re-run the code chunks to see those revised results until you find the pairs you are happy with.
male <- c("2652") # Replace the number here with the ID number of your male of interest.
female <- c("2677") # Replace the number here with the ID number of your female of interest.
pair <- c(male, female)
Now we are going to print something called a Kappa Triangle. This is a way to visualize the most probable identity by descent (IBD) for this pair in a 2-dimensional space.
kappa.pair <- coeff_living %>%
filter(xor((id1 == male & id2 == female),
(id1 == female & id2 == male))) %>%
select(id1, id2, kappa0, kappa1, kappa2)
kappa.tbl <- datatable(kappa.pair)
kappa.tri <- showInTriangle(kappa.pair, plotType = "plotly")
The red X mark represents the relationship between your hypothetical pair, while the letters in the graphic above are reference points for where different relationships would fall in that space. The summary table below contains a key for those abbreviations (and their associated values plotted above).
Now we can reconstruct our network visualizations with clearer annotations to focus on our proposed pair.
Recall that these plots can be slower to load, but they should be quicker now that we are only working with a subplot.
Also, note that the subtitle of these plots now contains a printed
summary produced by the verbalise package that is part of
pedsuite.
pair.net <- subset_network_btp(ped.living, colors, pair, studbook)
pair.vert <- pair.net %>% visHierarchicalLayout(direction = "UD", shakeTowards = "roots")
Now you should use all the information provided to match at least one breeding pair for your new exhibit and add a paragraph in which you explain this choice and plan.
Knit button at the top of this panel and wait for R Studio
to convert your document into an html report.
.html, .png, or .csv. You may
find any of these useful later.The Prosimian TAG has set a target population size of 55 animals in the Pygmy Slow Loris SSP population. The managed population has been increasing (λ = 0.96) historically, and has retained 92.39% of its founding gene diversity.
This SSP species first appeared in AZA facilities in 1968 when a single male was confiscated and transferred to the Honolulu Zoo. From 1968 – 1986, the population size remained low, never exceeding four individuals, and the Honolulu Zoo remained the only holding institution. The current SSP population was founded in 1987 when the San Diego Zoo, Duke Lemur Center, and Cincinnati Zoo imported 29 individuals from Sweden. The first recorded births occurred in 1988 at all three facilities that worked to import animals. The population steadily grew to a peak of 76 individuals by 2011 (Figure 1). This growth can largely be attributed to successful breeding and secondly to a small number of continued imports. Since 2012, the population has experienced a notable decline in size primarily due to insufficient reproduction. The reasons for this low, inconsistent reproduction in recent years are currently unclear, but may be associated with husbandry, particularly diet. However, the population has shown growth over the last five years again and there are enough births to offset deaths in the population.
Add your text here.
Genetic values are calculated after incorporating pedigree assumptions and removing excluded individuals. Analysis of the studbook indicates that this SSP is descended from 30 founders with no potential founders remaining (Figure 3, Table 2). The gene diversity of the population is 92%. Based on current founder representations, gene diversity is equivalent to that found in approximately six founders. The current mean kinship in the population is 0.0799; first-cousins have a kinship of 0.0625, which means that the average relationship in the population is slightly closer than that of noninbred first-cousins.
Population management theory suggests genetic management should strive to maintain thresholds for tolerance of gene diversity loss. The standard goal is 90% gene diversity retention for 100 years. Decreases in gene diversity below 90% of that in the founding population have been associated with increasingly compromised reproduction by, among other factors, lower birth/hatch weights, smaller litter/clutch sizes, and greater neonatal mortality in some species.
Based on current population parameters, gene diversity is projected to decline to 66% over the next 100 years if the current population grows to the recommended target size of 55 (Table 3, Scenario a). The most effective ways this population can maintain more gene diversity are to have an increasing growth rate (vs. stable) and a larger long-term population size. The effective population size is high and is helping to maintain gene diversity in this population.
Add your text here.
| SB ID | Local ID | Sex | Age | Disposition | Location | Breeding | With |
|---|---|---|---|---|---|---|---|
| 2623 | M14052 | M | 14 | HOLD | NY BRONX | BREED WITH | 2640 |
| 2640 | M14053 | F | 12 | HOLD | NY BRONX | BREED WITH | 2623 |
| 2682 | M19007 | M | 7 | RECEIVE FROM | BLOOMINGT | BREED WITH | 2708 |
| 2708 | 116283 | F | 4 | RECEIVE FROM | NZP-WASH | BREED WITH | 2682 |
| SB ID | Local ID | Sex | Age | Disposition | Location | Breeding | With |
|---|---|---|---|---|---|---|---|
| 2708 | 116283 | 4 | 14 | SEND TO | NY BRONX | BREED WITH | 2682 |
| 2715 | 116282 | 3 | 12 | HOLD | NZP-WASH | DO NOT BREED | |
| 2735 | 116461 | 0 | 7 | HOLD | NZP-WASH | DO NOT BREED | |
| 2736 | 116462 | 0 | 4 | HOLD | NZP-WASH | DO NOT BREED |
| SB ID | Local ID | Sex | Age | Disposition | Location | Breeding | With |
|---|---|---|---|---|---|---|---|
| 2652 | 24485 | M | 11 | HOLD | OMAHA | BREED WITH | 2677 |
| 2677 | 24709 | F | 7 | HOLD | OMAHA | BREED WITH | 2652 |
Note: For your summary you should write a few sentences explaining the choice you made. You may use a table format like this, a bulleted list, or a paragraph to present your proposed breeding pair(s).
Add your text here.